;;; Mudsync --- Live hackable MUD
;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
;;;
;;; This file is part of Mudsync.
;;;
;;; Mudsync is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; Mudsync is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mudsync.  If not, see <http://www.gnu.org/licenses/>.

(define-module (mudsync parser)
  #:use-module (rx irregex)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)

  #:export (match-to-kwargs
            split-verb-and-rest
            article preposition

            cmatch-indir-obj
            cmatch-direct-obj
            cmatch-direct-obj-greedy
            cmatch-empty
            cmatch-greedy))

(define (match-to-kwargs irx string)
  (let ((rx-match (irregex-match irx string)))
    (if rx-match
        (fold
         (match-lambda*
           (((match-part . idx) prev)
            (cons (symbol->keyword match-part)
                  (cons (irregex-match-substring
                         rx-match idx)
                        prev))))
         '()
         (irregex-match-names rx-match))
        #f)))

(define (split-verb-and-rest string)
  (let* ((trimmed (string-trim-both string))
         (first-space (string-index trimmed #\space)))
    (if first-space
        (cons (substring trimmed 0 first-space)
              (substring trimmed (+ 1 first-space)))
        (cons trimmed ""))))

;; @@: Not currently used
;; Borrowed from irregex.scm
(define match-string
  '(seq #\" (* (or (~ #\\ #\") (seq #\\ any))) #\"))

;; definite and indefinite, but not partitive articles
(define article '(or "the" "a" "an"))
(define preposition '(or "with" "in" "on" "out of" "at" "as" "to"
                         "about"))

(define indirect-irx
  (sre->irregex
   `(: (? (: ,preposition (+ space)))  ; possibly a preposition
       (? (: ,article (+ space)))      ; possibly an article (ignored)
       (=> direct-obj (* any))      ; direct object (kept)
       (+ space)
       (=> preposition ,preposition)   ; main preposition (kept)
       (+ space)
       (? (: ,article (+ space)))      ; possibly an article (ignored)
       (=> indir-obj (+ any))))) ; indirect object (kept)

(define (cmatch-indir-obj phrase)
  (match-to-kwargs indirect-irx phrase))

(define direct-irx
  (sre->irregex
   `(: (? (: ,preposition (+ space)))  ; possibly a preposition (ignored)
       (? (: ,article (+ space)))     ; possibly an article (ignored)
       (=> direct-obj (+ any)))))  ; direct object (kept)

(define (cmatch-direct-obj phrase)
  (match-to-kwargs direct-irx phrase))

(define (cmatch-empty phrase)
  (if (equal? (string-trim phrase) "")
      '()
      #f))

(define (cmatch-direct-obj-greedy phrase)
  ;; Turns out this uses the same semantics as splitting verb/rest
  (match (split-verb-and-rest phrase)
    ((direct-obj . rest)
     (list #:direct-obj direct-obj
           #:rest rest))
    (#f #f)))

(define (cmatch-greedy phrase)
  `(#:phrase ,phrase))

;; (define say-example "say I really need to get going.")
;; (define attack-sword-example "hit goblin with sword")
;; (define attack-simple-example "hit goblin")
;; (define put-book-on-desk "put the book on the desk")
